;;; -*-Mode:LISP; Package:ZWEI; Base:10 ; Readtable:ZL -*-

;;; Keep track of inter-message references.

;;; Each mail-file-buffer has a hash table that is used to hash
;;; each reference (an object that describes what is referenced)
;;; against an example of this data structure.
;;; Only messages in the mail file are mentioned.

(DEFSTRUCT (REFERENCE-ENTRY :LIST)
  REFERENCE-ENTRY-REFERENCED-MSGS       ;List of msgs this ref refers TO.
  REFERENCE-ENTRY-REFERENCING-MSGS)     ;List of msgs that refer using this ref.

(DEFUN MAKE-REFERENCE-HASH-TABLE ()
  (MAKE-HASH-TABLE :COMPARE-FUNCTION 'REFERENCE-COMPARE
                   :HASH-FUNCTION 'REFERENCE-HASH
                   :area *zmail-msg-area*))

(defun reference-identifier (reference)
  (let ((loc (locf reference)))
    (or (get loc :message-id)
        (truncate (or (get loc :date) 0) 60.))))

(defun reference-hash (reference)
  (let ((ref-id (reference-identifier reference)))
    (values (sxhash ref-id) (si:%pointer-volatility ref-id))))

(defun reference-compare (ref1 ref2)
  (equal (reference-identifier ref1)
         (reference-identifier ref2)))

(DEFUN HASH-RECORD-MSG-REFERENCES (MSG HT)
  "Record MSG in HT, a hash table of inter-message references.
Updates the data on MSG if MSG has changed, adding and removing entries as appropriate."
  (LET* ((STATUS (ASSURE-MSG-PARSED MSG))
         (OREFS (GET STATUS 'RECORDED-REFERENCES))
         (OIDS (GET STATUS 'RECORDED-MSG-IDS))
         (NREFS (MSG-REFERENCES MSG))
         (NIDS (MSG-IN-REFERENCES MSG)))
    (UNLESS (AND (EQUAL OIDS (OR NIDS T)) (EQUAL OREFS (OR NREFS T)))
      (IF OREFS (HASH-UNRECORD-MSG MSG HT))
      (DOLIST (ID NIDS)
        (LET ((HASHENTRY (GETHASH ID HT)))
          (UNLESS HASHENTRY
            (SETQ HASHENTRY (LIST NIL NIL))
            (PUTHASH ID HASHENTRY HT))
          (UNLESS (MEMQ MSG (REFERENCE-ENTRY-REFERENCED-MSGS HASHENTRY))
            (PUSH MSG (REFERENCE-ENTRY-REFERENCED-MSGS HASHENTRY)))))
      (DOLIST (REF NREFS)
        (LET ((HASHENTRY (GETHASH REF HT)))
          (UNLESS HASHENTRY
            (SETQ HASHENTRY (LIST NIL NIL))
            (PUTHASH REF HASHENTRY HT))
          (UNLESS (MEMQ MSG (REFERENCE-ENTRY-REFERENCING-MSGS HASHENTRY))
            (PUSH MSG (REFERENCE-ENTRY-REFERENCING-MSGS HASHENTRY)))))
      (PUTPROP STATUS (OR NIDS T) 'RECORDED-MSG-IDS)
      (PUTPROP STATUS (OR NREFS T) 'RECORDED-REFERENCES))))

(DEFUN HASH-UNRECORD-MSG (MSG HT)
  "Remove MSG from HT, a hash table of inter-message references.
You can use this when about to kill MSG, or if MSG must be re-recorded
because its contents have changed."
  (LET* ((STATUS (LOCF (MSG-STATUS MSG)))
         (OREFS (GET STATUS 'RECORDED-REFERENCES))
         (OIDS (GET STATUS 'RECORDED-MSG-IDS)))
    (UNLESS (EQ OIDS T)
      (DOLIST (ID OIDS)
        (LET ((HASHENTRY (GETHASH ID HT)))
          (WHEN HASHENTRY
            (SETF (REFERENCE-ENTRY-REFERENCED-MSGS HASHENTRY)
                  (DELQ MSG (REFERENCE-ENTRY-REFERENCED-MSGS HASHENTRY)))))))
    (UNLESS (EQ OREFS T)
      (DOLIST (REF OREFS)
        (LET ((HASHENTRY (GETHASH REF HT)))
          (WHEN HASHENTRY
            (SETF (REFERENCE-ENTRY-REFERENCING-MSGS HASHENTRY)
                  (DELQ MSG (REFERENCE-ENTRY-REFERENCING-MSGS HASHENTRY)))))))
    (PUTPROP STATUS NIL 'RECORDED-MSG-IDS)
    (PUTPROP STATUS NIL 'RECORDED-MSG-REFERENCES)))

;;; External interface.

;Use :UPDATE-REFERENCES to cause the hash table to be made up-to-date.
;Use :UNCACHE-REFERENCES to say that you have made changes to many existing messages
;so all should be reparsed and rerecorded in the hash table.
;Use :UNCACHE-MSG to say you have changed one message.
;Use :REFERENCED-MSGS to get the messages referred to by a list of references.
;Use :REFERENCING-MSGS to get the messages referring to any of a list of msg-ids.
;(A msg-id is the same thing as a reference).

;These operations work on all buffers, but use a hash table only for mail-file-buffers.

(DEFUN UNCACHE-MSG-REFERENCES (MSG)
  (SEND (MSG-MAIL-FILE-BUFFER MSG) :UNCACHE-MSG MSG))

;; Enter in the hash table any messages that are not in it.
;; Assumes that HASH-UNRECORD-MSG has been used to unhash
;; any messages that have changed; also, any moved-in messages will not be in it.
(DEFMETHOD (MAIL-FILE-BUFFER :UPDATE-REFERENCES) ()
  (WITHOUT-INTERRUPTS
    (UNLESS REFERENCE-HASH-TABLE
      (SETQ REFERENCE-HASH-TABLE (MAKE-REFERENCE-HASH-TABLE))))
  (LOOP FOR MSG BEING THE MSGS IN SELF
        DO
        (UNLESS (GET (LOCF (MSG-STATUS MSG)) 'RECORDED-REFERENCES)
          (HASH-RECORD-MSG-REFERENCES MSG REFERENCE-HASH-TABLE))))

(DEFMETHOD (MAIL-FILE-BUFFER :UNCACHE-REFERENCES) ()
  (DOMSGS (MSG SELF)
    (LET ((-STATUS- (ASSURE-MSG-PARSED MSG)))
      (REMPROP -STATUS- 'RECORDED-REFERENCES)
      (REMPROP -STATUS- 'RECORDED-MSG-IDS)))
  (CLRHASH REFERENCE-HASH-TABLE))

(DEFMETHOD (MAIL-FILE-BUFFER :UNCACHE-MSG) (MSG)
  (HASH-UNRECORD-MSG MSG REFERENCE-HASH-TABLE))

(DEFMETHOD (MAIL-FILE-BUFFER :REFERENCED-MSGS) (REFERENCES)
  (SEND SELF :UPDATE-REFERENCES)
  (MAPCAN #'(LAMBDA (REFERENCE)
              (SUBSET 'MSG-REFERENCE-EQUAL
                      (REFERENCE-ENTRY-REFERENCED-MSGS
                        (GETHASH REFERENCE REFERENCE-HASH-TABLE))
                      (CIRCULAR-LIST REFERENCE)))
          REFERENCES))

(DEFMETHOD (MAIL-FILE-BUFFER :REFERENCING-MSGS) (MSG-IDS)
  (SEND SELF :UPDATE-REFERENCES)
  (MAPCAN #'(LAMBDA (ID)
              (SUBSET #'(LAMBDA (MSG)
                          (LOOP FOR REF IN (MSG-REFERENCES MSG)
                            THEREIS (REFERENCE-ALL-MATCH REF ID)))
                      (REFERENCE-ENTRY-REFERENCING-MSGS
                        (GETHASH ID REFERENCE-HASH-TABLE))))
          MSG-IDS))

(DEFMETHOD (ZMAIL-BUFFER :UNCACHE-REFERENCES) () NIL)

(DEFMETHOD (ZMAIL-BUFFER :UNCACHE-MSG) (IGNORE) NIL)

(DEFMETHOD (ZMAIL-BUFFER :UPDATE-REFERENCES) () NIL)

(DEFMETHOD (ZMAIL-BUFFER :REFERENCED-MSGS) (REFERENCES)
  (MAPCAN #'(LAMBDA (REFERENCE)
              (LOOP FOR MSG BEING THE MSGS IN SELF
                    WHEN (MSG-REFERENCE-EQUAL MSG REFERENCE)
                    COLLECT MSG))
          REFERENCES))

(DEFMETHOD (ZMAIL-BUFFER :REFERENCING-MSGS) (MSG-IDS)
  (MAPCAN #'(LAMBDA (ID)
              (LOOP FOR MSG BEING THE MSGS IN SELF
                    WHEN
                    (LOOP FOR REF IN (MSG-REFERENCES MSG)
                          THEREIS (REFERENCE-COMPARE REF ID))
                    COLLECT MSG))
          MSG-IDS))

;; Interface between references and messages.

(DEFUN MSG-REFERENCE-EQUAL (MSG REF)
  "T if MSG is one of the messages referred to by references REF."
  (LOOP FOR (IND PROP) ON REF BY 'CDDR
        WITH STATUS = (ASSURE-MSG-PARSED MSG)
        ALWAYS (REFERENCE-EQUAL PROP
                                (IF (EQ IND :FROM)
                                    (CAR (GET STATUS IND))
                                  (GET STATUS IND))
                                IND)))

(DEFUN REFERENCE-ALL-MATCH (REF MSG-ID)
  (LOOP FOR (IND PROP) ON REF BY 'CDDR
        WITH STATUS = (LOCF MSG-ID)
        ALWAYS (REFERENCE-EQUAL PROP (GET STATUS IND) IND)))

(DEFUN REFERENCE-EQUAL (REF-PROP MSG-PROP IND)
  (AND MSG-PROP
       (CASE IND
         (:DATE
          ;; Don't compare the seconds.
          (= (TRUNCATE (IF (CONSP REF-PROP) (CAR REF-PROP) REF-PROP) 60.)
             (TRUNCATE (IF (CONSP MSG-PROP) (CAR MSG-PROP) MSG-PROP) 60.)))
         (:FROM (LOOP FOR (IND PROP) ON REF-PROP BY 'CDDR
                      ALWAYS
                      (OR (EQ IND :HOST)
                          (EQUAL PROP (GET (LOCF MSG-PROP) IND)))))
         (OTHERWISE (EQUAL REF-PROP MSG-PROP)))))

(DEFUN MSG-IN-REFERENCES (MSG &AUX STATUS)
  "Return a list of references whereby this message may be referenced."
  (SETQ STATUS (ASSURE-MSG-PARSED MSG))
  (OR (GET STATUS 'IN-REFERENCES)
      (LET* ((MSG-ID (GET STATUS :MESSAGE-ID))
             (DATE (GET STATUS :DATE))
             (FROM (SOME-PLIST (CAR (GET STATUS :FROM)) '(:NAME)))
             (IN-REFERENCES
               (IF MSG-ID
                   (IF (AND DATE FROM)
                       `((:MESSAGE-ID ,MSG-ID)
                         (:FROM ,FROM :DATE ,DATE))
                     `((:MESSAGE-ID ,MSG-ID)))
                 (IF (AND DATE FROM)
                     `((:FROM ,FROM :DATE ,DATE))
                   NIL))))
        (PUTPROP STATUS IN-REFERENCES 'IN-REFERENCES))))

(DEFUN MSG-REFERENCES (MSG &AUX STATUS TEM)
  "Return a list of the references of MSG.
Each element is a reference that may match another MSG (the one referred to).
Use MSG-REFERENCE-EQUAL to match a message against a reference."
  (SETQ STATUS (ASSURE-MSG-PARSED MSG))
  (IF (SETQ TEM (GETL STATUS '(REFERENCES)))
      (CADR TEM)
      (SETQ TEM (GET-MSG-REFERENCES MSG STATUS))
      (PUTPROP STATUS TEM 'REFERENCES)
      TEM))

(DEFUN GET-MSG-REFERENCES (MSG STATUS)
  ;; If there is an IN-REPLY-TO field, use what is says, else get from text
  (IF (GETL STATUS *REFERENCE-TYPE-HEADERS*)
      (LOOP FOR IND IN *REFERENCE-TYPE-HEADERS*
            APPEND (GET STATUS IND))
      (GET-MSG-TEXT-REFERENCES MSG)))

(DEFUN SOME-MSG-FITS-REFERENCE (MSGS REFERENCE)
  (DOLIST (MSG MSGS)
    (IF (MSG-REFERENCE-EQUAL MSG REFERENCE) (RETURN T))))

(DEFUN TRACE-REFERENCES-RECURSIVELY (MSG BUFFER FORWARD-FLAG BACKWARD-FLAG)
"First value is a list of all references traced through.
Second value is a list of all messages thus reached."
  (UNLESS BUFFER
    (IF *NUMERIC-ARG-P*
        (MULTIPLE-VALUE-BIND (MAP-FUNCTION MAP-ARG)
            (GET-UNIVERSE-FUNCTION '(:MOUSE) "Universe to search")
          (SETQ BUFFER (EXPAND-UNIVERSE-FUNCTION MAP-FUNCTION MAP-ARG)))
      (SETQ BUFFER *ZMAIL-BUFFER*)))
  (LET* ((REFERENCES (APPEND (IF FORWARD-FLAG (MSG-REFERENCES MSG))
                             (COPYLIST (IF BACKWARD-FLAG (MSG-IN-REFERENCES MSG)))))
         (REFS-LIST-TAIL (LAST REFERENCES))
         (MSGS (LIST MSG))
         (MSGS-TAIL MSGS)
         (REFS-SCANNING-POINTER REFERENCES))
    (DO ()
        ((NULL REFS-SCANNING-POINTER))
      (LET ((REF (CAR REFS-SCANNING-POINTER)))
        (WHEN FORWARD-FLAG
          (LET ((MSGS-REFD (SEND BUFFER :REFERENCED-MSGS (LIST REF))))
            (DOLIST (M MSGS-REFD)
              (UNLESS (MEMQ M MSGS)
                (SETF (VALUES REFS-LIST-TAIL MSGS-TAIL)
                      (TRACE-REFERENCES-RECURSIVELY-ADD-MSG M REFS-LIST-TAIL MSGS-TAIL
                                                            FORWARD-FLAG BACKWARD-FLAG))))))
        (WHEN BACKWARD-FLAG
          (LET ((MSGS-REFFING (SEND BUFFER :REFERENCING-MSGS (LIST REF))))
            (DOLIST (M MSGS-REFFING)
              (UNLESS (MEMQ M MSGS)
                (SETF (VALUES REFS-LIST-TAIL MSGS-TAIL)
                      (TRACE-REFERENCES-RECURSIVELY-ADD-MSG M REFS-LIST-TAIL MSGS-TAIL
                                                            FORWARD-FLAG BACKWARD-FLAG)))))))
      (POP REFS-SCANNING-POINTER))
    (LOOP FOR REF IN REFERENCES
          WITH FLAG = NIL
          UNLESS (SOME-MSG-FITS-REFERENCE MSGS REF)
          DO (UNLESS FLAG (FORMAT QUERY-IO "~&Some referents cannot be found.")
                     (SETQ FLAG T))
;            (TERPRI)
;            (PRINT-REFERENCE *STANDARD-OUTPUT* REF NIL)
             )
    (VALUES MSGS REFERENCES)))

(DEFUN EXPAND-UNIVERSE-FUNCTION (MAP-FUNCTION MAP-ARG)
  (CASE MAP-FUNCTION
    (MAP-OVER-SINGLE-ZMAIL-BUFFER MAP-ARG)
    ;; The next two are not really implemented right, but who cares?
    (MAP-OVER-REST-OF-ZMAIL-BUFFER MAP-ARG)
    (MAP-OVER-BEGINNING-OF-ZMAIL-BUFFER MAP-ARG)
    (MAP-OVER-DEFINED-UNIVERSE (EXPAND-UNIVERSE MAP-ARG))
    ((MAP-OVER-ALL-ZMAIL-BUFFERS MAP-OVER-LOADED-ZMAIL-BUFFERS)
     #'(LAMBDA (OP &OPTIONAL ARG)
         (CASE OP
           ((:UNCACHE-REFERENCES :UPDATE-REFERENCES)
            (DOLIST (B *ZMAIL-BUFFER-LIST*)
              (SEND B OP)))
           (:UNCACHE-MSG
            (DOLIST (B *ZMAIL-BUFFER-LIST*)
              (SEND B OP ARG)))
           ((:REFERENCED-MSGS :REFERENCING-MSGS)
            (LOOP FOR B IN *ZMAIL-BUFFER-LIST*
                  NCONC (SEND B OP ARG))))))))

(DEFUN TRACE-REFERENCES-RECURSIVELY-ADD-MSG (MSG REFS-TAIL MSG-TAIL
                                             FORWARD-FLAG BACKWARD-FLAG)
  (SETF (CDR MSG-TAIL) (NCONS MSG))
  (IF FORWARD-FLAG
      (SETF (CDR REFS-TAIL)
            (COPYLIST* (MSG-REFERENCES MSG))))
  (IF BACKWARD-FLAG
      (SETF (CDR REFS-TAIL)
            (COPYLIST* (MSG-IN-REFERENCES MSG))))
  (VALUES (IF (CDR REFS-TAIL) (LAST REFS-TAIL) REFS-TAIL)
          (LAST MSG-TAIL)))

(DEFUN MAKE-ZMAIL-BUFFER-OF-REFERENCES (MSG FORWARD-FLAG BACKWARD-FLAG &AUX MF)
  (SETQ MF (GET-RECYCLED-TEMP-ZMAIL-BUFFER "<References>"))
  (LET ((MSGS (TRACE-REFERENCES-RECURSIVELY
                MSG NIL FORWARD-FLAG BACKWARD-FLAG))
        (ARRAY (ZMAIL-BUFFER-ARRAY MF)))
    (DOLIST (M (SORT MSGS 'MSG-DATE-SORT-LESSP))
      (VECTOR-PUSH-EXTEND M ARRAY)))
  MF)
